;;;;;; class-file.scm - Class File module.    -*- Mode: Scheme -*-
;;;;;; Author: Erik Silkensen <silkense@colorado.edu>
;;;;;; Version: 28 Jun 2009

#lang scheme

(require srfi/13)           ; provides String Libraries
(require "binary-io.scm")
(require "constant-pool.scm")
(require "attributes.scm")

;;; See Ch. 4 of the Java(TM) Virtual Machine Specification for
;;; documentation of the class File Format:
;;; <http://java.sun.com/docs/books/jvms>

;;; This module provides a constructor for a Class File object, along
;;; with integer constants for the possible access flags.

;;; The Class File object follows the pattern in Ch. 3 of Structure and
;;; Interpretation of Computer Programs. The object is a procedure:
;;;     (let ((cf (make-class-file "Foo")))
;;;       ((cf '<method>) <arg1> <arg2>))

(provide
 make-class-file
 ACC-PUBLIC
 ACC-PRIVATE
 ACC-PROTECTED
 ACC-STATIC
 ACC-FINAL
 ACC-SYNCHRONIZED
 ACC-VOLATILE
 ACC-TRANSIENT
 ACC-NATIVE
 ACC-INTERFACE
 ACC-ABSTRACT
 ACC-STRICT)

(define ACC-PUBLIC #x0001)
(define ACC-PRIVATE #x0002)
(define ACC-PROTECTED #x0004)
(define ACC-STATIC #x0008)
(define ACC-FINAL #x0010)
(define ACC-SYNCHRONIZED #x0020)
(define ACC-VOLATILE #x0040)
(define ACC-TRANSIENT #x0080)
(define ACC-NATIVE #x0100)
(define ACC-INTERFACE #x0200)
(define ACC-ABSTRACT #x0400)
(define ACC-STRICT #x0800)

(define (java-name->jvm-name name)
  (string-map
   (lambda (c) 
     (if (char=? #\. c) 
         #\/ 
         c)) 
   name))

(define (make-class-file name [super "java/lang/Object"] [access ACC-PUBLIC])
  ;; Class File objects contain all information for a Java class file.
  ;; Name and super should be string names of the class and its parent
  ;; class to create. Access should be some combination of the access
  ;; flags.
  (define (add-attribute! attribute)
    ;; Adds an attribute object to the Class File. The only requirement
    ;; of an attribute is that it has a write method.
    (set! attributes (append attributes (list attribute))))
  (define (add-interface! name)
    ;; Adds an interface of the specified name to the Class File.
    (let ((interface ((pool 'Class) (java-name->jvm-name name))))
      (set! interfaces (append interfaces (list interface)))))
  (define (add-field! name type access)
    ;; Adds a field of the specified name and type, and with the
    ;; specified access level, to the Class File.
    (let ((field (make-member name type access '())))
      (set! fields (append fields (list field)))))
  (define (add-method name type access)
    ;; Adds a method of the specified name to the Class File. The type
    ;; should be the string descriptor of the method, and the access
    ;; should be the integer access flag. A code attribute for the
    ;; method is created and returned.
    (let* ((is-static (= (bitwise-and access ACC-STATIC) ACC-STATIC))
           (code (make-code-attribute type pool is-static))
           (method (make-member name type access (list code))))
      (set! methods (append methods (list method)))
      code))
  (define (make-member name type access attributes)
    ;; <PRIVATE> Creates a member object with the specified name. The
    ;; type should be the string descriptor of the member, and the
    ;; access should be the integer access flag. Attributes should be a
    ;; list of attribute objects. A member is either a method or a field
    ;; of this class.
    (define (write [out (current-output-port)])
      ;; Writes the member to the output port. See Ch. 4.6. of the
      ;; Java(TM) Virtual Machine Specification.
      (write-short access out)
      (write-short name out)
      (write-short type out)
      (write-attributes attributes out))
    (define this
      ;; The object is a procedure that returns a method from this table.
      (let ((method-table `((write . ,write))))
        (lambda (method)
          (let ((proc (assq method method-table)))
            (if proc
                (cdr proc)
                (error "undefined method -- MEMBER" method))))))
    
    (set! name ((pool 'Utf8) name))
    (set! type ((pool 'Utf8) type))
    this)
  (define (write [out (current-output-port)])
    ;; Writes the Class File object to the output port. See Ch. 4.1. of
    ;; the Java(TM) Virtual Machine Specification.
    (let ((this-class ((pool 'Class) name))
          (super-class ((pool 'Class) super)))
      (write-int #xcafebabe out)
      (write-short minor-version out)
      (write-short major-version out)
      ((pool 'write) out)
      (write-short access out)
      (write-short this-class out)
      (write-short super-class out)
      (write-short (length interfaces) out)
      (for-each (lambda (interface)
                  (write-short interface out))
                interfaces)
      (write-attributes fields)
      (write-attributes methods)
      (write-attributes attributes)))
  (define attributes '())
  (define interfaces '())
  (define fields '())
  (define methods '())
  (define pool (make-constant-pool))
  (define minor-version 0)
  (define major-version 50) ; J2SE 6.0
  (define this
    ;; The object is a procedure that returns a method from this table.
    (let ((method-table `((add-attribute! . ,add-attribute!)
                          (add-interface! . ,add-interface!)
                          (add-field! . ,add-field!)
                          (add-method . ,add-method)
                          (write . ,write)
                          (pool . ,pool)
                          (name . ,name))))
      (lambda (method)
        (let ((proc (assq method method-table)))
          (if proc
              (cdr proc)
              (error "undefined method -- CLASS-FILE" method))))))
  (set! name (java-name->jvm-name name))
  (set! super (java-name->jvm-name super))
  this)
